home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / Pascal / Snippets / LoopSndDemo / LoopSndDemo.p < prev    next >
Encoding:
Text File  |  1997-01-15  |  6.9 KB  |  274 lines  |  [TEXT/PJMM]
  1. program LoopSndDemo;
  2.  
  3. {Based on sndDemo by Marv Westrom, with major modifications by Ingemar Ragnemalm.}
  4.  
  5. {This demo plays sampled music continuously, able to repeat one sample or switching}
  6. {between them. A callback procedure is used for immediately starting the next sample}
  7. {when the previous has finished.}
  8.  
  9. {I sampled the music from Frank Zappa's "Ya Hozna". Please make your own samples for}
  10. {your games. This is just for the demo.}
  11.  
  12.     uses
  13. {$IFC UNDEFINED THINK_PASCAL}
  14.         Types, QuickDraw, Events, Menus, Dialogs, Fonts, Resources, Devices,{}
  15.         Memory, WIndows, TextEdit, OSUtils, MixedMode, Processes, 
  16. {$ELSEC}
  17. {$SETC GENERATINGPOWERPC := false}
  18. {$ENDC}
  19.         Sound;
  20.  
  21.  
  22. {Memory management calls for holding interrupt code in memory, for compatibility with}
  23. {Virtual Memory. I couldn't find these in Think Pascal, so I'm adding them here. They should}
  24. {be available in the Univ Interfaces.}
  25. {$IFC UNDEFINED THINK_PASCAL}
  26. {$ELSEC}
  27.     function HoldMemory (address: univ Ptr; count: LONGINT): OSErr;
  28.     inline
  29.         $225F, $205F, $7000, $A05C, $3E80;
  30.     function UnholdMemory (address: univ Ptr; count: LONGINT): OSErr;
  31.     inline
  32.         $225F, $205F, $7001, $A05C, $3E80;
  33. {$ENDC}
  34.  
  35.     var { necessary globals }
  36.         gMySndChannel: SndChannelPtr;
  37.  
  38.     type
  39.         IntPtr = ^INTEGER;
  40.  
  41. {We assume format 1 here. That should be fixed so format 2 is also allowed}
  42.     function SndData (sh: Handle): Ptr; { sh must be locked upon call }
  43.         var
  44.             s, c: INTEGER;
  45.             p: Ptr;
  46.     begin
  47.         p := sh^;
  48.         if IntPtr(p)^ = firstSoundFormat then
  49.             begin
  50.                 s := IntPtr(ORD4(p) + 2)^;
  51.                 p := Ptr(ORD4(p) + s * 6);
  52.             end;
  53.         p := Ptr(ORD4(p) + 4);
  54.         c := IntPtr(p)^;
  55.         SndData := Ptr(ORD4(p) + 2 + c * 8);
  56.     end; {SndData}
  57.  
  58. {$PUSH}
  59. {$D-}
  60. {The A5 stuff is not necessary since I don't use any globals from callback}
  61. {I included it just in case it becomes interesting later.}
  62.     procedure MyCallBack (chan: sndChannelPtr; var cmd: SndCommand);
  63.         var
  64.             myA5: longint;
  65.             mySndCmd: SndCommand;
  66.             myErr: OSErr;
  67.     begin
  68.         if cmd.param1 = 99 then
  69.             begin
  70.                 myA5 := SetA5(chan^.userInfo);
  71.  
  72.                 mySndCmd.cmd := bufferCmd;
  73.                 mySndCmd.param1 := 0;
  74.                 mySndCmd.param2 := cmd.param2;
  75.                 myErr := SndDoCommand(chan, mySndCmd, false);
  76.  
  77.                 mySndCmd.cmd := callBackCmd;
  78.                 mySndCmd.param1 := 99;                { arbitrary code to check MyCallback }
  79.                 mySndCmd.param2 := cmd.param2;
  80.                 myErr := SndDoCommand(chan, mySndCmd, false);
  81.  
  82.                 myA5 := SetA5(myA5);
  83.             end;
  84.     end; {MyCallBack}
  85. {$POP}
  86.  
  87.     function AllocateSoundChannel: SndChannelPtr;
  88.         var
  89.             myErr: OSErr;
  90.             theChannel: SndChannelPtr;
  91.  {$IFC GENERATINGPOWERPC }
  92.             callbackProc: ProcPtr;
  93. {$ENDC}
  94.     begin
  95.         theChannel := nil;
  96. {$IFC GENERATINGPOWERPC}
  97.         callbackProc := NewRoutineDescriptor(@MyCallBack, uppSndCallBackProcInfo, GetCurrentArchitecture); {GetCurrentISA?}
  98.         myErr := SndNewChannel(theChannel, 5, initMono + initNoInterp, callbackProc);
  99. {$ELSEC}
  100.         myErr := SndNewChannel(theChannel, 5, initMono + initNoInterp, @MyCallBack);
  101. {$ENDC}
  102.         theChannel^.userInfo := SetCurrentA5; {Not necessary since I don't use any globals from callback - but you may want to}
  103.         AllocateSoundChannel := theChannel;
  104.     end; {AllocateSoundChannel}
  105.  
  106.     procedure AsynchChangePlay (sndH, loopH: handle);
  107.         var
  108.             mySndCmd: sndCommand;
  109.             myErr: OSErr;
  110.     begin
  111.         if gMySndChannel = nil then
  112.             gMySndChannel := AllocateSoundChannel;
  113.         if gMySndChannel = nil then
  114.             Exit(AsynchChangePlay);
  115.  
  116.         if (sndH = nil) or (loopH = nil) then
  117.             Exit(AsynchChangePlay);
  118.  
  119.         mySndCmd.cmd := flushCmd;
  120.         mySndCmd.param1 := 0;
  121.         mySndCmd.param2 := 0;
  122.         myErr := SndDoImmediate(gMySndChannel, mySndCmd);
  123.  
  124.         mySndCmd.cmd := bufferCmd;
  125.         mySndCmd.param1 := 0;
  126.         mySndCmd.param2 := Ord4(SndData(sndH));
  127.         myErr := SndDoCommand(gMySndChannel, mySndCmd, false);
  128.  
  129.         mySndCmd.cmd := callBackCmd;
  130.         mySndCmd.param1 := 99;
  131.         mySndCmd.param2 := Ord4(SndData(loopH));
  132.         myErr := SndDoCommand(gMySndChannel, mySndCmd, false);
  133.  
  134.     end; {AsynchChangePlay}
  135.  
  136.     procedure AsyncEndPlay;
  137.         var
  138.             mySndCmd: sndCommand;
  139.             myErr: OSErr;
  140.     begin
  141.         mySndCmd.cmd := quietCmd;
  142.         myErr := SndDoCommand(gMySndChannel, mySndCmd, false);
  143.         myErr := SndDisposeChannel(gMySndChannel, true);
  144.     end; {AsyncEndPlay}
  145.  
  146.     procedure InitMacintosh;
  147.     begin
  148. {$IFC UNDEFINED THINK_PASCAL}
  149.         MaxApplZone;
  150.  
  151.         InitGraf(@qd.thePort);
  152.         InitFonts;
  153.         FlushEvents(everyEvent, 0);
  154.         InitWindows;
  155.         InitMenus;
  156.         TEInit;
  157.         InitDialogs(nil);
  158. {$ENDC}
  159.         InitCursor;
  160.     end; {InitMacintosh}
  161.  
  162.  
  163.     function GetNamedSound (name: Str255): Handle;
  164.         var
  165.             sndH: Handle;
  166.     begin
  167.         sndH := GetNamedResource('snd ', name);
  168.         if sndH <> nil then
  169.             begin
  170.                 LoadResource(sndH);
  171.                 MoveHHi(sndH);
  172.                 Hlock(sndH);
  173.                 GetNamedSound := sndH;
  174.             end;
  175.     end; {GetNamedSound}
  176.  
  177. {Variables that are local to the main procedure.}
  178.     var
  179.         sndHiThere: Handle;
  180.         sndPrelude, sndStart, sndMain, sndAlt: Handle;
  181.         i, times: integer;
  182.         startTicks: Longint;
  183.     const
  184.         kDelayTime = 1;
  185.         kHoldHowMuch = 1000;
  186.     var
  187.         err: OSErr;
  188.  
  189. begin
  190.     InitMacintosh;
  191.  
  192.     sndPrelude := GetNamedSound('Förspel');
  193.     sndStart := GetNamedSound('Start');
  194.     sndMain := GetNamedSound('Main test');
  195.     sndAlt := GetNamedSound('Mellantest');
  196.  
  197. {$IFC UNDEFINED THINK_PASCAL}
  198. {$ELSEC}
  199.     ShowText;
  200. {$ENDC}
  201.  
  202.     WriteLn('Welcome to LoopSndDemo!');
  203.     WriteLn('You should now hear a tune by Frank Zappa.');
  204.     WriteLn('Click to advance phase.');
  205.  
  206. {The callback function must never be swapped out by Virtual Memory!}
  207. {Unfortunately, there is no way that I know to get theexact size of a procedure.}
  208. {For example, the following is not reliable:}
  209. {if noErr <> HoldMemory(@MyCallBack, Longint(@AllocateSoundChannel) - Longint(@MyCallBack)) then}
  210. {In my experiments, it seems correct when using 68k code, but not with PPC code, since the order}
  211. {of procedures are different. Instead, I use a constant kHoldHowMuch. If it is large enough, it should work.}
  212.  
  213.     err := HoldMemory(@MyCallBack, kHoldHowMuch);
  214.     if noErr <> err then
  215.         WriteLn('Error when calling HoldMemory!', err);
  216.  
  217. {Allocate the sound channel by calling AllocateSoundChannel.}
  218.     gMySndChannel := AllocateSoundChannel;
  219.  
  220.     AsynchChangePlay(sndPrelude, sndPrelude);
  221.     i := 0;
  222.     repeat
  223.         i := i + 1;
  224.         Write(i : 3, ' ');
  225.         if (i mod 25) = 0 then
  226.             WriteLn;
  227.         Delay(kDelayTime, startTicks);
  228.     until Button;
  229.     WriteLn(Char(13), 'Switch to phase 2!');
  230.     while Button do
  231.         ;
  232.  
  233.     AsynchChangePlay(sndStart, sndMain);
  234.     repeat
  235.         i := i + 1;
  236.         Write(i : 3, ' ');
  237.         if (i mod 25) = 0 then
  238.             WriteLn;
  239.         Delay(kDelayTime, startTicks);
  240.     until Button;
  241.     WriteLn(Char(13), 'Switch to phase 3!');
  242.     while Button do
  243.         ;
  244.  
  245.     AsynchChangePlay(sndAlt, sndAlt);
  246.     repeat
  247.         i := i + 1;
  248.         Write(i : 3, ' ');
  249.         if (i mod 25) = 0 then
  250.             WriteLn;
  251.         Delay(kDelayTime, startTicks);
  252.     until Button;
  253.     WriteLn(Char(13), 'Switch to phase 4!');
  254.     while Button do
  255.         ;
  256.  
  257.     AsynchChangePlay(sndMain, sndMain);
  258.     repeat
  259.         i := i + 1;
  260.         Write(i : 3, ' ');
  261.         if (i mod 25) = 0 then
  262.             WriteLn;
  263.         Delay(kDelayTime, startTicks);
  264.     until Button;
  265.     WriteLn(Char(13), 'Quitting!');
  266.  
  267.     AsyncEndplay;
  268.  
  269. {Release the callback from being unswappable.}
  270.     if noErr <> UnholdMemory(@MyCallBack, kHoldHowMuch) then
  271.         WriteLn('Error when calling UnholdMemory!');
  272.  
  273.     ExitToShell; {To avoid stupid SIOUX "save?" questions.}
  274. end.